home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / demos / moire.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-01  |  3.0 KB  |  125 lines
  1. Program Moire;
  2.  
  3. {
  4.       Will now open a default screen (can be any size) with
  5.       the new look. The window get it's size depending on
  6.       the screen size.
  7.       14 May 1998
  8.  
  9.       Translated to FPC from PCQ Pascal.
  10.       15 Aug 1998.
  11.  
  12.       Changed to use vartags and pas2c.
  13.       18 Jan 2000.
  14.  
  15.       nils.sjoholm@mailbox.swipnet.se
  16. }
  17.  
  18. uses Exec, Intuition, Graphics, Utility, vartags;
  19.  
  20.  
  21. const
  22.     pens : array [0..0] of Integer = ( not 0);
  23.     
  24.  
  25. var
  26.     w  : pWindow;
  27.     s  : pScreen;
  28.     m  : pMessage;
  29.  
  30.  
  31. Procedure DoDrawing(RP : pRastPort);
  32. var
  33.     x  : word;
  34.     Pen : Byte;
  35.     Stop : word;
  36. begin
  37.     Pen := 1;
  38.     while true do begin
  39.     with w^ do begin
  40.         x := 0;
  41.         while x < Pred(Width - BorderRight - BorderLeft) do begin
  42.         Stop := Pred(Width - BorderRight);
  43.         SetAPen(RP, Pen);
  44.         Move(RP, Succ(x + BorderLeft), BorderTop);
  45.         Draw(RP, Stop - x, Pred(Height - BorderBottom));
  46.         Pen := (Pen + 1) mod 4;
  47.         Inc(x);
  48.         end;
  49.         m := GetMsg(UserPort);
  50.         if m <> Nil then
  51.         Exit;
  52.         x := 0;
  53.         while x < Pred(Height - BorderBottom - BorderTop) do begin
  54.         Stop := Pred(Height - BorderBottom);
  55.         SetAPen(RP, Pen);
  56.         Move(RP, Pred(Width - BorderRight), Succ(x + BorderTop));
  57.         Draw(RP, Succ(BorderLeft), Stop - x);
  58.         Pen := (Pen + 1) mod 4;
  59.         Inc(x);
  60.         end;
  61.         m := GetMsg(UserPort);
  62.         if m <> Nil then
  63.         Exit;
  64.     end;
  65.     end;
  66. end;
  67.  
  68. begin
  69.     { Note that the startup code of all FPC programs depends on
  70.       Intuition, so if we got to this point Intuition must be
  71.       open, so the run time library just uses the pointer that
  72.       the startup code created.  Same with DOS, although we don't
  73.       use that here. }
  74.  
  75.     GfxBase := OpenLibrary(GRAPHICSNAME,0);
  76.     if GfxBase <> nil then begin
  77.  
  78.     s := OpenScreenTagList(NIL, TAGS(
  79.     SA_Pens,      longint(@pens),
  80.     SA_Depth,     2,
  81.     SA_DisplayID, HIRES_KEY,
  82.     SA_Title,     Longstr('Close the Window to End This Demonstration'),
  83.     TAG_END));
  84.  
  85.     if s <> NIL then begin
  86.  
  87.     w := OpenWindowTagList(NIL, TAGS(
  88.     WA_IDCMP,        IDCMP_CLOSEWINDOW,
  89.     WA_Left,         20,
  90.     WA_Top,          50,
  91.     WA_Width,        336,
  92.     WA_Height,       100,
  93.     WA_MinWidth,     50,
  94.     WA_MinHeight,    20,
  95.     WA_MaxWidth,     -1,
  96.     WA_MaxHeight,    -1,
  97.     WA_DepthGadget,  ltrue,
  98.     WA_DragBar,      -1,
  99.     WA_CloseGadget,  -1,
  100.     WA_SizeGadget,   -1,
  101.     WA_SmartRefresh, -1,
  102.     WA_Activate,     -1,
  103.     WA_Title,        Longstr('Feel Free to Re-Size the Window'),
  104.     WA_CustomScreen, Long(s),
  105.     TAG_END));
  106.  
  107.     IF w <> NIL THEN begin
  108.  
  109.         DoDrawing(w^.RPort);
  110.         Forbid;
  111.         repeat
  112.             m := GetMsg(w^.UserPort);
  113.         until m = nil;
  114.         CloseWindow(w);
  115.         Permit;
  116.         end else
  117.         writeln('Could not open the window');
  118.         CloseScreen(s);
  119.     end else
  120.         writeln('Could not open the screen.');
  121.     CloseLibrary(GfxBase);
  122.     end else writeln('no graphics.library');
  123. end.
  124.  
  125.